type
 PBlock = ^TBlock;
 TBlock = record
  Ptr: Pointer;
  Size: PtrInt;
 end;

const
 HeapCount = 256;

var Blocks: array[0..HeapCount-1] of TBlock;
	 cnt: ptrint = 0;

procedure DumpMem;
var i: ptrint;
begin
	writeln('Heap:');
	for i := 0 to cnt-1 do
		WriteLn(' Block: ', PtrUint(blocks[i].ptr), ' Size: ',blocks[i].Size, '(',blocks[i].size div 1024, ' kb)');
end;

function contains(blk: TBlock; Ptr: Pointer): boolean;
begin
	result := (PtrUInt(blk.ptr) <= ptruint(ptr)) and ((ptruint(blk.ptr)+blk.size) > ptruint(ptr));
end;

procedure RegisterBlock(Ptr: pointer; size: PtrInt); [public, alias: 'RegisterBlock'];
var x: ptrint;
begin
	if size <= 0 then
		exit;
   
	x := cnt;
	inc(cnt);
	
	Blocks[x].ptr := ptr;
	Blocks[x].size := size;
end;

procedure ReserveBlock(Ptr: pointer; size: PtrInt); [public, alias: 'ReserveBlock'];
var i, left, right: ptrint;
	 rptr: pointer;
	 blk: tblock;
begin
	if size <= 0 then
		exit;
	
	blk.ptr := ptr;
	blk.size := size;
	
	begin
		for i := 0 to cnt-1 do
		begin
			if contains(blocks[i], ptr) or contains(blk, blocks[i].ptr) then
			begin
				left := PtrUInt(blk.ptr)-PtrUInt(blocks[i].ptr);
				
				rptr := Pointer(PtrUInt(size)+PtrUInt(ptr));
				right := (blocks[i].size+PtrUInt(blocks[i].ptr))-(blk.size+PtrUInt(blk.ptr));
				
            if left < 0 then
               left := 0;
            
				blocks[i].size := left;
				
				registerblock(rptr, right);
			end;
		end;
	end;
end;

function KGetMem(size: PtrUInt): Pointer; [public, alias: 'KGetMem'];
var i: ptrint;
begin
	result := nil;
	if size <= 0 then
		exit;
	
	for i := 0 to cnt-1 do
	begin
		if blocks[i].size >= size then
		begin
			result := blocks[i].ptr;
			blocks[i].ptr := pointer(ptruint(blocks[i].ptr)+size);
			dec(blocks[i].size, size);
			exit;
		end;
	end;
end;

procedure KFreeMem(Ptr: Pointer; Size: PtrUInt); [public, alias: 'KFreeMem'];
begin
	registerblock(ptr, size);
end;

function AllocPages(Size: longint): pointer;
var t: PtrUInt;
begin
	result := KGetMem(Size+4096);
	t := PtrUInt(result) mod 4096;
	if t > 0 then
	begin
		KFreemem(result, t);
		result := Pointer(PtrUInt(result+4096-t));
	end;
end;

procedure DeallocPages(Ptr: Pointer; size: longint);
begin
   KFreeMem(Ptr, Size);
end;

function GetMem(Size: PtrInt): Pointer;
begin
   result := nil;
   if size <= 0 then
      exit;
   
	result := KGetMem(size+SizeOf(PtrInt));
   assert(assigned(result), 'Couldn''t allocate memory');
	PPtrInt(Result)[0] := size;
	Result := Pointer(PtrUInt(Result)+SizeOf(PtrInt));
end;

procedure FreeMem(Ptr: Pointer);
begin
   if ptr = nil then
      exit;
   
	KFreeMem(@PPtrInt(Ptr)[-1], PPtrInt(Ptr)[-1]+SizeOf(PtrInt));
end;

function GetMemSize(ptr: pointer): ptrint;
begin
   result := PPtrInt(Ptr)[-1];
end;

function GetAlignedMem(Size, Alignment: PtrInt): Pointer;
var t: PtrUInt;
begin
	result := KGetMem(Size+Alignment+SizeOf(PtrInt));
   assert(assigned(result), 'Couldn''t allocate memory');
   
	t := (PtrUInt(result)+SizeOf(PtrInt)) mod PtrUInt(Alignment);
	if t > 0 then
	begin
		KFreemem(result, t-sizeof(ptruint));
		result := Pointer(PtrUInt(result+Alignment-t+SizeOf(PtrInt)));
	end
   else
      result := Pointer(PtrUInt(result)+SizeOf(PtrInt));
	PPtrInt(result-sizeof(ptrint))^ := Size;
end;

function ReallocMem(var Ptr: Pointer; Size: PtrInt): Pointer;
var x: PtrInt;
begin
   result := getmem(size);
   
   if Ptr <> nil then
   begin
      x := PPtrInt(ptr)[-1];
      if size < x then
         x := size;
      
      move(pbyte(ptr)^, pbyte(result)^, x);
   end
   else
      fillchar(pbyte(result)^, size, 0);
   
   ptr := result;
end;

function fpc_getmem(size:ptruint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
begin
   fpc_GetMem := GetMem(size);
end;

procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
begin
   FreeMem(p);
end;